home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 015 / ffutil.arc / MAKEPRD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-03-29  |  11.7 KB  |  562 lines
  1. Program CvtFF;
  2.  
  3. {$B+}
  4. {$V-}
  5.  
  6. const
  7.    MaxChar = 255;
  8.  
  9. type
  10.    DoubIntg = array[1..2] of Integer;
  11.    String80 = String[80];
  12.    tRegs = record case boolean of
  13.             false: (Ax,Bx,Cx,Dx,Bp,Si,Di,Ds,Es,Flags: Integer);
  14.             true:  (Al,Ah,Bl,Bh,Cl,Ch,Dl,Dh: Byte);
  15.             end;
  16.  
  17.    tFontHdr = record
  18.                   C26:        Integer;
  19.                   CNull1:     Byte;
  20.                   FontType:   Byte;
  21.                   CNull2:     Integer;
  22.                   BaseLine:   Integer;
  23.                   Width:      Integer;
  24.                   Height:     Integer;
  25.                   Orient:     Byte;
  26.                   Fixed:      Byte;
  27.                   SymSet:     Integer;
  28.                   Pitch:      Integer;
  29.                   Points:     Integer;
  30.                   CNull3:     Integer;
  31.                   CNull4:     Byte;
  32.                   Style:      Byte;
  33.                   Weight:     Byte;
  34.                   TypeFace:   Byte;
  35.                   end;
  36.  
  37.    tCharHdr = record
  38.                   C4:         Byte;
  39.                   CNull1:     Byte;
  40.                   C14:        Byte;
  41.                   C1:         Byte;
  42.                   Orient:     Byte;
  43.                   CNull2:     Byte;
  44.                   LeftOffset: Integer;
  45.                   TopOffset:  Integer;
  46.                   CWidth:     Integer;
  47.                   CHeight:    Integer;
  48.                   DeltaX:     Integer;
  49.                   end;
  50.  
  51.    tCharEnt =  record
  52.                   ChNbr:      Byte;
  53.                   Orient:     Byte;
  54.                   LeftOffset: Integer;
  55.                   TopOffset:  Integer;
  56.                   CWidth:     Integer;
  57.                   CHeight:    Integer;
  58.                   DeltaX:     Integer;
  59.                   end;
  60.    tFont =  record
  61.                FontType:   Byte;
  62.                BaseLine:   Integer;
  63.                Width:      Integer;
  64.                Height:     Integer;
  65.                Orient:     Byte;
  66.                Fixed:      Byte;
  67.                SymSet:     Integer;
  68.                Pitch:      Integer;
  69.                Points:     Integer;
  70.                Style:      Byte;
  71.                Weight:     Byte;
  72.                TypeFace:   Byte;
  73.                Chars:      array[0..MaxChar] of tCharEnt;
  74.                end;
  75.    tpFont = ^tFont;
  76.  
  77.    tFName = String[40];
  78.  
  79.    tMasks = array[0..7] of byte;
  80.  
  81. const
  82.    DefRegs: tRegs = (Ax:0;Bx:0;Cx:0;Dx:0;Bp:0;Si:0;Di:0;Ds:0;Es:0;Flags:0);
  83.    Masks: tMasks = ($80,$40,$20,$10,8,4,2,1);
  84.  
  85. var
  86.    FFile:      Integer;
  87.    FFName:     tFName;
  88.    FLen:       DoubIntg;
  89.    FPos:       DoubIntg;
  90.  
  91.    Font:       tpFont;
  92.  
  93.    MinCn:      Byte;
  94.    MaxCn:      Byte;
  95.  
  96.    Ch:         Char;
  97.  
  98. function GEDoubIntg(
  99.        V1:     DoubIntg;
  100.        V2:     DoubIntg): Boolean;
  101.  
  102.    var
  103.       Result: Boolean;
  104.  
  105.    begin {GEDoubIntg}
  106.  
  107.    if v1[1]>v2[1] then
  108.       Result:=true
  109.    else if v1[1]<v2[1] then
  110.       Result:=false
  111.    else if (v1[2]<0) and (v2[2]>=0) then
  112.       Result:=true
  113.    else if (v1[2]>=0) and (v2[2]<0) then
  114.       Result:=false
  115.    else
  116.       Result:= V1[2]>=V2[2];
  117.  
  118.    GEDoubIntg:=Result;
  119.  
  120.    end {GEDoubIntg};
  121.  
  122. procedure AddDoubIntg(
  123.    var V:      DoubIntg;
  124.        Offset: Integer);
  125.  
  126.    var
  127.       P1:   Integer;
  128.       P2:   Integer;
  129.  
  130.    begin {AddDoubIntg}
  131.  
  132.    P1:=V[2] and $FF;
  133.    P2:=V[2] shr 8;
  134.  
  135.    P1:=P1+Offset;
  136.  
  137.    P2:=P2+ (P1 shr 8);
  138.    P1:=P1 and $FF;
  139.  
  140.    V[1]:=V[1] + (P2 shr 8);
  141.    P2:=P2 and $FF;
  142.    V[2]:=(P2 shl 8) + P1;
  143.  
  144.    end {AddDoubIntg};
  145.  
  146. procedure CloseFont(
  147.    var FNbr:      Integer);
  148.  
  149.    var
  150.       Regs: tRegs;
  151.  
  152.    begin {CloseFont}
  153.  
  154.    if FNbr<>0 then
  155.       begin
  156.       Regs:=DefRegs;
  157.       Regs.Ah:=$3E;
  158.       Regs.Bx:=FNbr;
  159.       MsDos(Regs);
  160.       end;
  161.  
  162.    FNbr:=0;
  163.  
  164.    end {CloseFont};
  165.  
  166. procedure OpenFont(
  167.        Create:    Boolean;
  168.        Name:      tFName;
  169.    var FNbr:      Integer;
  170.    var FLen:      DoubIntg;
  171.    var Error:     Integer);
  172.  
  173.    var
  174.       Regs: tRegs;
  175.  
  176.    begin {OpenFont}
  177.  
  178.    Error:=0;
  179.  
  180.    if FNbr<>0 then
  181.       CloseFont(FNbr);
  182.  
  183.    Name[ord(Name[0])+1]:=#0;
  184.    Regs:=DefRegs;
  185.    if Create then
  186.       begin
  187.       Regs.Ax:=$3C00;
  188.       Regs.Cx:=32;
  189.       end
  190.    else
  191.       Regs.Ax:=$3D00;
  192.    Regs.Ds:=Seg(Name[1]);
  193.    Regs.Dx:=Ofs(Name[1]);
  194.    MsDos(Regs);
  195.    if odd(Regs.Flags) then
  196.       begin
  197.       Error:=Regs.Ax;
  198.       Regs.Ax:=0;
  199.       end;
  200.    FNbr:=Regs.Ax;
  201.  
  202.    if not Create and (Error=0) then
  203.       begin
  204.       Regs.Ah:=$42;
  205.       Regs.Al:=2;
  206.       Regs.Bx:=FNbr;
  207.       Regs.Cx:=0;
  208.       Regs.Dx:=0;
  209.       MsDos(Regs);
  210.       FLen[1]:=Regs.Dx;
  211.       FLen[2]:=Regs.Ax;
  212.       end;
  213.  
  214.  
  215.    end {OpenFont};
  216.  
  217. procedure MoveFromFont(
  218.        Nbr:          Integer;
  219.        FirstByte:    DoubIntg;
  220.    var Dest;
  221.        Len:          Integer);
  222.  
  223.    var
  224.       Regs:  tRegs;
  225.  
  226.    begin {MoveFromFont}
  227.  
  228.    Regs:=DefRegs;
  229.    with Regs do
  230.       begin
  231.       Ax:=$4200;
  232.       Bx:=Nbr;
  233.       Cx:=FirstByte[1];
  234.       Dx:=FirstByte[2];
  235.       end;
  236.    MsDos(Regs);
  237.  
  238.    Regs:=DefRegs;
  239.    with Regs do
  240.       begin
  241.       Ax:=$3F00;
  242.       Bx:=Nbr;
  243.       Cx:=Len;
  244.       Dx:=Ofs(Dest);
  245.       Ds:=Seg(Dest);
  246.       end;
  247.    MsDos(Regs);
  248.  
  249.    end {MoveFromFont};
  250.  
  251. procedure MoveToFont(
  252.        Nbr:          Integer;
  253.    var Src;
  254.        Len:          Integer);
  255.  
  256.    var
  257.       Regs:  tRegs;
  258.  
  259.    begin {MoveToFont}
  260.  
  261.    Regs:=DefRegs;
  262.    with Regs do
  263.       begin
  264.       Ax:=$4000;
  265.       Bx:=Nbr;
  266.       Cx:=Len;
  267.       Dx:=Ofs(Src);
  268.       Ds:=Seg(Src);
  269.       end;
  270.    MsDos(Regs);
  271.  
  272.    end {MoveToFont};
  273.  
  274. procedure GetFontNameAndOpen(
  275.        LabelStr:     String80;
  276.        Create:       Boolean;
  277.    var FontName:     tFName;
  278.    var FontFile:     Integer;
  279.    var FLen:         DoubIntg);
  280.  
  281.    var
  282.       IoStatus: Integer;
  283.       DumbFile: File;
  284.  
  285.    begin {GetFontNameAndOpen}
  286.  
  287.    repeat
  288.       FontFile:=0;
  289.       FontName:='';
  290.       write(trm,LabelStr);
  291.       readln(trm,fontname);
  292.       if length(fontname)>0 then
  293.          begin
  294.          if Create then
  295.             begin
  296.             Assign(DumbFile,FontName);
  297.       {$I-} Erase(DumbFile);  {$I+}
  298.             IoStatus:=IoResult;
  299.             end;
  300.          OpenFont(create,FontName,FontFile,FLen,IoStatus);
  301.          if iostatus<>0 then
  302.             begin
  303.             writeln(trm,^G'Open Error ',IoStatus:1);
  304.             read(kbd,ch);
  305.             if (Ch=^C) then
  306.                Halt;
  307.             end;
  308.          end
  309.       else
  310.          write(trm,^G);
  311.  
  312.    until IoStatus=0;
  313.  
  314.    end {GetFontNameAndOpen};
  315.  
  316. procedure GetNumber(
  317.    var Num:    Integer;
  318.    var Ch:     Char);
  319.  
  320.    begin
  321.  
  322.    num:=0;
  323.    repeat
  324.       MoveFromFont(FFile,fpos,ch,1);
  325.       if (Ch>='0') and (Ch<='9') then
  326.          begin
  327.          num:=10*num+(ord(ch)-48);
  328.          adddoubintg(fpos,1);
  329.          end;
  330.    until (Ch<'0') or (Ch>'9');
  331.  
  332.    end;
  333.  
  334. procedure GetFontHeader(
  335.    var FontHdr:   tFontHdr);
  336.  
  337.    var
  338.       Str:  String[3];
  339.       Num:  Integer;
  340.       Ch:   Char;
  341.  
  342.    begin
  343.  
  344.    MoveFromFont(FFile,fpos,str[1],3);
  345.    str[0]:=#3;
  346.    if str=^[')s' then
  347.       begin
  348.       AddDoubIntg(FPos,3);
  349.       GetNumber(Num,Ch);
  350.       AddDoubIntg(FPos,1);
  351.       MoveFromFont(FFile,FPos,FontHdr,26);
  352.       AddDoubIntg(FPos,Num);
  353.       end;
  354.  
  355.    end;
  356.  
  357. procedure GetCharId(
  358.    var Cn:  Byte);
  359.  
  360.    var
  361.       Str:  String[3];
  362.       Ch:   Char;
  363.       Num:  Integer;
  364.  
  365.    begin
  366.  
  367.    MoveFromFont(FFile,fpos,str[1],3);
  368.    str[0]:=#3;
  369.    if str=^['*c' then
  370.       begin
  371.       AddDoubIntg(FPos,3);
  372.       GetNumber(Num,Ch);
  373.       Cn:=Num;
  374.       AddDoubIntg(FPos,1);
  375.       end;
  376.  
  377.    end;
  378.  
  379. procedure GetCharDef(
  380.    var CharHdr:   tCharHdr);
  381.  
  382.    var
  383.       Str:  String[3];
  384.       Ch:   Char;
  385.       Num:  Integer;
  386.  
  387.    begin
  388.  
  389.    MoveFromFont(FFile,fpos,str[1],3);
  390.    str[0]:=#3;
  391.    if str=^['(s' then
  392.       begin
  393.       AddDoubIntg(FPos,3);
  394.       GetNumber(Num,Ch);
  395.       AddDoubIntg(FPos,1);
  396.       MoveFromFont(FFile,fpos,charhdr,16);
  397.       AddDoubIntg(FPos,Num);
  398.       end;
  399.  
  400.    end;
  401.  
  402. procedure ReadFont;
  403.  
  404.    var
  405.       Ch:         Char;
  406.       Cn:         Byte;
  407.       FontHdr:    tFontHdr;
  408.       CharHdr:    tCharHdr;
  409.       X:          Byte;
  410.  
  411.    begin {ReadFont}
  412.  
  413.    for cn:=0 to maxchar do
  414.       Font^.Chars[Cn].ChNbr:=0;
  415.  
  416.    GetFontNameAndOpen('Read Font: ',false,Ffname,FFile,FLen);
  417.    FPos[1]:=0;
  418.    FPos[2]:=0;
  419.  
  420.    if FFile>0 then
  421.       begin
  422.       GetFontHeader(FontHdr);
  423.       Font^.FontType:=FontHdr.FontType;
  424.       Font^.BaseLine:=swap(FontHdr.BaseLine);
  425.       Font^.Width:=swap(FontHdr.Width);
  426.       Font^.Height:=swap(FontHdr.Height);
  427.       Font^.Orient:=FontHdr.Orient;
  428.       Font^.Fixed:=FontHdr.Fixed;
  429.       Font^.SymSet:=swap(FontHdr.SymSet);
  430.       Font^.Pitch:=swap(FontHdr.Pitch);
  431.       Font^.Points:=swap(FontHdr.Points);
  432.       Font^.Style:=FontHdr.Style;
  433.       Font^.Weight:=FontHdr.Weight;
  434.       Font^.TypeFace:=FontHdr.TypeFace;
  435.  
  436.       mincn:=255;
  437.       maxcn:=0;
  438.  
  439.       while not GEDoubIntg(FPos,FLen) do
  440.          begin
  441.          GetCharId(Cn);
  442.          GetCharDef(CharHdr);
  443.          if cn<mincn then
  444.             mincn:=cn;
  445.          if cn>maxcn then
  446.             maxcn:=cn;
  447.          write(trm,^M^['K',cn:1);
  448.          with Font^.Chars[cn] do
  449.             begin
  450.             ChNbr:=Cn;
  451.             Orient:=CharHdr.Orient;
  452.             LeftOffset:=swap(CharHdr.LeftOffset);
  453.             TopOffset:=swap(CharHdr.TopOffset);
  454.             CWidth:=swap(CharHdr.CWidth);
  455.             CHeight:=swap(CharHdr.CHeight);
  456.             DeltaX:=swap(CharHdr.DeltaX) div 4;
  457.             end;
  458.          x:=0;
  459.          while (x=0) and not GEDoubIntg(FPos,FLen) do
  460.             begin
  461.             movefromfont(FFile,FPos,X,1);
  462.             if X=0 then
  463.                AddDoubIntg(FPos,1);
  464.             end;
  465.          end;
  466.       writeln(trm);
  467.  
  468.       CloseFont(FFile);
  469.       end;
  470.  
  471.    end {ReadFont};
  472.  
  473. procedure WritePrd;
  474.  
  475.    var
  476.       FontName:tFName;
  477.       PrdName: tFName;
  478.       Prd:     text;
  479.       Cn:      Byte;
  480.       Cntr:    Byte;
  481.  
  482.    begin {WritePrd}
  483.  
  484.  
  485.    write(trm,'What name should font have for MsWord? ');
  486.    readln(trm,fontname);
  487.    write(trm,'Prd name? ');
  488.    readln(trm,prdname);
  489.    assign(prd,prdname);
  490.    rewrite(prd);
  491.  
  492.    writeln(prd,'{F0');
  493.    writeln(prd,'CTP:NIL');
  494.    writeln(prd,'cPSDs:1');
  495.    writeln(prd);
  496.    writeln(prd,'FontSize:',(600 div Font^.Pitch));
  497.    writeln(prd,'Wtps:W0 W0 W0 W0');
  498.  
  499.    write(prd,'beginmod:0 "');
  500.    write(prd,'^[(',(font^.symset div 32):1,chr((font^.symset mod 32)+64));
  501.    write(prd,'^[(s');
  502.    if font^.fixed=0 then
  503.       write(prd,'0p',(1200.0/font^.pitch):5:2,'h')
  504.    else
  505.       write(prd,'1p');
  506.    write(prd,(72.0*(font^.points/1200.0)):5:2,'v');
  507.    write(prd,font^.style:1,'s');
  508.    write(prd,font^.weight:1,'b');
  509.    write(prd,font^.typeface:1,'T');
  510.    writeln(prd,'"');
  511.  
  512.    writeln(prd,'endmod:0 "^[(st12vp10H"');
  513.    writeln(prd,'FontName:',fontname);
  514.    writeln(prd,'}F');
  515.  
  516.    writeln(prd);
  517.    writeln(prd,'{W0');
  518.    writeln(prd,'FontSize:144 chFirst:',mincn:1,' chLast:',maxcn:1);
  519.  
  520.    cntr:=0;
  521.    for cn:=mincn to maxcn do with Font^.Chars[Cn] do
  522.       begin
  523.       write(prd,cn:4,':');
  524.       if ChNbr<>0 then
  525.          begin
  526.          write(prd,deltax:1);
  527.          if deltax<10 then
  528.             write(prd,' ');
  529.          end
  530.       else
  531.          write(prd,'0 ');
  532.       cntr:=cntr+1;
  533.       if cntr>5 then
  534.          begin
  535.          writeln(prd);
  536.          cntr:=0;
  537.          end;
  538.       end;
  539.    if cntr>0 then
  540.       writeln(prd);
  541.    writeln(prd,'}W');
  542.    writeln(prd);
  543.  
  544.    close(prd);
  545.  
  546.    end {WritePrd};
  547.  
  548. begin
  549.  
  550. DefRegs.Ds:=DSeg;
  551. DefRegs.Es:=DSeg;
  552.  
  553. new(Font);
  554.  
  555. writeln(trm,^J^J^J);
  556.  
  557. ReadFont;
  558.  
  559. WritePrd;
  560.  
  561. end.
  562.